home *** CD-ROM | disk | FTP | other *** search
/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / c / lmiter.lsp < prev    next >
Encoding:
Text File  |  1988-08-16  |  39.2 KB  |  1,453 lines
  1. ;;; -*- PACKAGE:KERMIT; BASE: 8; IBASE: 8; MODE:LISP -*-
  2.  
  3.  
  4. ;******************************************************************************
  5. ; Copyright (c) 1984, 1985 by Lisp Machine Inc.
  6. ; Symbolics-specific portions Copyright (c) 1985 by Honeywell, Inc.
  7. ; Permission to copy all or part of this material is granted, provided
  8. ; that the copies are not made or distributed for resale, and the 
  9. ; copyright notices and reference to the source file and the software
  10. ; distribution version appear, and that notice is given that copying is
  11. ; by permission of Lisp Machine Inc.  LMI reserves for itself the 
  12. ; sole commercial right to use any part of this KERMIT/H19-Emulator
  13. ; not covered by any Columbia University copyright.  Inquiries concerning
  14. ; copyright should be directed to Mr. Damon Lawrence at (213) 642-1116.
  15. ;
  16. ; Version Information:
  17. ;      LMKERMIT 1.0     --      Original LMI code, plus edit ;1; for 3600 port
  18. ;
  19. ; Authorship Information:
  20. ;      Mark David (LMI)           Original version, using KERMIT.C as a guide
  21. ;      George Carrette (LMI)      Various enhancements
  22. ;      Mark Ahlstrom (Honeywell)  Port to 3600 (edits marked with ";1;" comments)
  23. ;
  24. ; Author Addresses:
  25. ;      George Carrette     ARPANET: GJC at MIT-MC
  26. ;
  27. ;      Mark Ahlstrom       ARPANET: Ahlstrom at HI-Multics
  28. ;                          PHONE:   (612) 887-4006
  29. ;                          USMAIL:  Honeywell MN09-1400
  30. ;                                   Computer Sciences Center
  31. ;                                   10701 Lyndale Avenue South
  32. ;                                   Bloomington, MN  55420
  33. ;******************************************************************************
  34.  
  35.  
  36.  
  37. ;;; This program is KERMIT-TERMINAL.
  38. ;;;
  39. ;;; This is to be used to make your lisp machine terminal
  40. ;;; act like it is an "H19" terminal.
  41. ;;;
  42. ;;; No flavors are defined in this file. None of this code
  43. ;;; depends on anything having to do with flavors, except
  44. ;;; in so far as the lisp machine graphics operations require.
  45. ;;; This code contains a refreshingly low density of "messages."
  46. ;;; This makes the code so simple, I consider it ALMOST self explanatory.
  47. ;;;
  48. ;;; No "special" window is required. That is, a lisp listener
  49. ;;; should do fine. A tv:minimum-window will not, of course, work.
  50. ;;;
  51. ;;; For the H19 graphics protocol, see the Zenith manual for
  52. ;;; the Z29 terminal, which is available from the documentation
  53. ;;; department of LMI.
  54. ;;; ("Z-29 user's & technical guide"
  55. ;;;  Appendix B -- Zenith Mode Code Info
  56. ;;;  1983, Zenith Data Systems.)
  57. ;;;
  58. ;;;
  59.  
  60.  
  61.  
  62.  
  63. ;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  64.  
  65. ;;;       special variables
  66.  
  67. ;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  68.  
  69.  
  70.  
  71. ;;; To use this, you only need to bind three special variables:
  72.  
  73. ;;; 1. *TERMINAL*  This must be bound to a local input output window
  74. ;;;                           that gets input from the lisp machine's keyboard
  75. ;;;                           and mouse.
  76. ;;; 2. *SERIAL-STREAM*
  77. ;;;                    This must be bound to an serial stream (or some stream
  78. ;;;                           than supports the operations we use in this code.)
  79. ;;;                           To get this stream, on a Lambda Lisp Machine,
  80. ;;;                     you usually just call si:make-sdu-serial-stream
  81. ;;;                           with no arguments.
  82. ;;; 3. interaction-pane
  83. ;;;                    This is a pane in which to bind debug-io, trace-output, query-io, use
  84. ;;;                           the NETWORK key interactions and in general any thing not involved
  85. ;;;                           in normal terminal interaction.
  86. ;;;                           It will work (if you have a normal window for example) to just
  87. ;;;                           have this be the same stream as *terminal* is bound to. The requirement
  88. ;;;                           is that IT MUST BE AN EXPOSED WINDOW!!
  89. ;;;
  90.  
  91.  
  92. (DEFCONST *ESCAPE-DISPATCH-TABLE* (MAKE-HASH-TABLE))
  93.  
  94.  
  95. (DECLARE (SPECIAL INTERACTION-PANE
  96.           kermit-frame            ;1;
  97.           ))
  98.  
  99. (DEFCONST *SERIAL-STREAM* :unbound)
  100.  
  101. (DEFCONST *TERMINAL* :unbound)
  102.  
  103.  
  104. (DEFCONST *BAD-ESCAPES* ())
  105.  
  106.  
  107. (defconst *local-echo-mode* nil)
  108.  
  109.  
  110. (DEFCONST *LOGFILE* NIL)                                    ;where to log terminal session, if desired
  111.  
  112.  
  113. (DEFCONST TURN-ON-LOGGING? NIL)
  114.  
  115.  
  116.  
  117. (DEFCONST *TERMINAL-DEBUG-MODE* NIL)
  118.  
  119.  
  120.  
  121.  
  122.  
  123.                     
  124.  
  125.  
  126.  
  127. ;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  128.  
  129. ;;; TERMINAL GRAPHICS  AND OUTPUT "PRIMITIVES"
  130.  
  131. ;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  132.  
  133.  
  134.  
  135.  
  136. (DEFCONST *INSERT-FLAG* ())
  137.  
  138.  
  139.  
  140. (DEFCONST *REVERSE-VIDEO-FLAG* ())
  141.  
  142.  
  143.  
  144. (DEFCONST *CURSOR-SAVE* '(0 0))
  145.  
  146.  
  147.  
  148. (DEFCONST *SYSTEM-POSITION* '(0 0))
  149.  
  150.  
  151. (DEFCONST *USE-BIT-7-FOR-META* NIL)
  152.  
  153.  
  154.  
  155. (DEFCONST *AUTO-CR-ON-LF-FLAG* NIL)
  156.  
  157.  
  158.  
  159. (DEFCONST *AUTO-LF-ON-CR-FLAG* NIL)
  160.  
  161. ;1; #+3600
  162. ;1; (defconst *disable-outgoing-cr-to-crlf-conversion* t    
  163. ;1;   "Yes if you want return to just send a <cr> during terminal emulation.")    ;1; see the following note
  164.  
  165. ;1; **************** some experimental new stuff for 3600 ****************
  166. ;1; 
  167. ;1; The 3600 ascii translation that is "build in" to all :ascii-character
  168. ;1; streams has the unfortunate convention of turning outgoing <return> characters
  169. ;1; into <CR><LF> pairs, and converting incoming <CR><LF> pairs in <return> characters.
  170. ;1; This is usually ok, but with certain hosts, it works better if <return> actually
  171. ;1; sends just a <CR>.  For example, I found that I could only get proper Heath19
  172. ;1; emulation with our LAN and with Multics if I set *disable-return-to-crlf-conversion* 
  173. ;1; and *auto-lf-on-cr-flag* to true.
  174.  
  175. ;1; Note that this is pulled from >rel-6-sys>io>stream.lisp and modified...
  176. ;1; Also note that this should only be in effect when connected for terminal
  177. ;1; emulation.  It must work in the usual way for file transfers, etc.
  178.  
  179. ;1; #+3600
  180. ;1; (defvar kermit-connected-flag nil)        ;1; defined in lmiwin.
  181.  
  182. ;1; #+3600
  183. ;1; (DEFWHOPPER (si:ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN :TYO) (CH)
  184. ;1;   (COND ((and                    ;1; This first condition is the changed part.
  185. ;1;        kermit-connected-flag        ;1; if we are connected for terminal emulation and...
  186. ;1;        (char= ch #\CR)            ;1; char is <return> and...
  187. ;1;        *disable-outgoing-cr-to-crlf-conversion*)    ;1; and we want return to just send <cr>,
  188. ;1;      (continue-whopper #O015))        ;1; then do it that way.
  189. ;1;     ((CHAR= CH #\CR)            ;1; This rest is the normal function...
  190. ;1;      (CONTINUE-WHOPPER #O015)
  191. ;1;      (CONTINUE-WHOPPER #O012))
  192. ;1;     (T (CONTINUE-WHOPPER (CHAR-TO-ASCII CH)))))
  193.  
  194.  
  195. (DEFSUBST TERMINAL-INSERT-CHAR ()
  196.   (SEND *TERMINAL* ':INSERT-CHAR 1 ':CHARACTER))
  197.  
  198.  
  199.  
  200.  
  201.  
  202. (DEFSUBST TERMINAL-ERASE-ALUF ()
  203.   (SEND *TERMINAL* ':ERASE-ALUF))
  204.  
  205.  
  206.  
  207.  
  208.  
  209. (DEFSUBST TERMINAL-SET-ERASE-ALUF (ALU)
  210.   (SEND *TERMINAL* ':SET-ERASE-ALUF ALU))
  211.  
  212.  
  213.  
  214.  
  215.  
  216. (DEFSUBST TERMINAL-TYO (CHAR-CODE)
  217.   (SEND *TERMINAL* ':TYO CHAR-CODE))
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  
  224. (DEFSUBST TERMINAL-READ-CURSORPOS ()
  225.   (SEND *TERMINAL* ':READ-CURSORPOS ':CHARACTER))
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232. (DEFSUBST TERMINAL-SET-CURSORPOS (X Y)
  233.   (SEND *TERMINAL* ':SET-CURSORPOS
  234.           X Y
  235.           ':CHARACTER))
  236.  
  237.  
  238.  
  239.  
  240.  
  241. (DEFSUBST TERMINAL-INSERT-LINE (&OPTIONAL (NTIMES 1))
  242.   #+3600 (send *terminal* :insert-line ntimes)    ;1; tv:sheet-insert-line is obsolete on 3600
  243.   #-3600 (TV:SHEET-INSERT-LINE *TERMINAL* NTIMES))
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250. (DEFSUBST TERMINAL-DELETE-LINE (&OPTIONAL (NTIMES 1))
  251.   #+3600 (send *terminal* :delete-line ntimes)    ;1; tv:sheet-delete-line obsolete on 3600
  252.   #-3600 (TV:SHEET-DELETE-LINE *TERMINAL* NTIMES))
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259. (DEFSUBST TERMINAL-CLEAR-CHAR ()
  260.   (SEND *TERMINAL* ':CLEAR-CHAR))
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270. (DEFSUBST TERMINAL-CHARACTER-WIDTH ()
  271.   (MULTIPLE-VALUE-BIND (WIDTH IGNORE)
  272.       (SEND *TERMINAL* ':SIZE-IN-CHARACTERS)
  273.     WIDTH))
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280. (DEFSUBST TERMINAL-CHARACTER-HEIGHT ()
  281.   (MULTIPLE-VALUE-BIND (IGNORE HEIGHT)
  282.       (SEND *TERMINAL* ':SIZE-IN-CHARACTERS)
  283.     HEIGHT))
  284.  
  285.  
  286.  
  287.  
  288.  
  289.  
  290. (DEFSUBST TERMINAL-END-OF-PAGE-EXCEPTION ()
  291.   (SEND *TERMINAL* ':HOME-CURSOR)
  292.   (SEND *TERMINAL* ':DELETE-LINE)
  293.   (TERMINAL-SET-CURSORPOS 0 (- (TERMINAL-CHARACTER-HEIGHT) 2)))
  294.  
  295.  
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302. (DEFSUBST TERMINAL-CR ()
  303.   (MULTIPLE-VALUE-BIND (IGNORE Y)
  304.       (TERMINAL-READ-CURSORPOS)
  305.     (TERMINAL-SET-CURSORPOS 0 Y)
  306.     (AND *AUTO-LF-ON-CR-FLAG*
  307.            (COND ((EQ Y (- (TERMINAL-CHARACTER-HEIGHT) 2))
  308.                     (TERMINAL-END-OF-PAGE-EXCEPTION))
  309.                  (T (TERMINAL-SET-CURSORPOS 0 (1+ Y)))))
  310.     NIL))
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317. (DEFSUBST TERMINAL-LINEFEED ()
  318.   (MULTIPLE-VALUE-BIND (X Y)
  319.       (TERMINAL-READ-CURSORPOS)
  320.     (COND ((EQ Y (- (TERMINAL-CHARACTER-HEIGHT) 2))
  321.              (TERMINAL-END-OF-PAGE-EXCEPTION))
  322.             (T (TERMINAL-SET-CURSORPOS
  323.                  (IF *AUTO-CR-ON-LF-FLAG* 0 X)
  324.                  (1+ Y))))
  325.     NIL))
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  
  333. (defsubst serial-tyi ()
  334.   (let ((ch? (send *serial-stream* ':tyi)))
  335.     (and ch? (logand ch? #o177))))
  336.  
  337.  
  338.  
  339.  
  340. (DEFSUBST TERMINAL-SAVE-POS-1 ()
  341.   (SETQ *SYSTEM-POSITION* (MULTIPLE-VALUE-LIST (TERMINAL-READ-CURSORPOS))))
  342.  
  343.  
  344.  
  345.  
  346. (DEFSUBST TERMINAL-RESTORE-POS-1 ()
  347.   (TERMINAL-SET-CURSORPOS (CAR *SYSTEM-POSITION*) (CADR *SYSTEM-POSITION*)))
  348.  
  349.  
  350.  
  351.  
  352.  
  353.  
  354. (DEFSUBST TERMINAL-GOTO-BEG-OF-LINE ()
  355.   (MULTIPLE-VALUE-BIND (IGNORE Y)
  356.       (TERMINAL-READ-CURSORPOS)
  357.     (TERMINAL-SET-CURSORPOS 0 Y)))
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  
  366.  
  367.  
  368.  
  369.  
  370. (DEFSUBST TERMINAL-BACKSPACE ()
  371.   (TERMINAL-TYO #\BACKSPACE))
  372.  
  373.  
  374.  
  375. (DEFSUBST TERMINAL-BEEP ()
  376.   (BEEP))
  377.  
  378.  
  379.  
  380.  
  381. (DEFSUBST TERMINAL-TAB ()
  382.   (TERMINAL-TYO #\TAB))
  383.  
  384.  
  385.  
  386.  
  387.  
  388.  
  389.  
  390.  
  391.  
  392.  
  393.  
  394.  
  395. ;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  396.  
  397. ;;;       definition of DEF-TERMINAL-ESCAPE
  398.  
  399. ;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  400.  
  401.  
  402.  
  403.  
  404.  
  405. (DEFMACRO DEF-TERMINAL-ESCAPE (KEY-NUMBER NEED-TO-DEFINE-P FUNCTION-NAME &BODY BODY)
  406.   (COND (NEED-TO-DEFINE-P
  407.            `(PROGN 'COMPILE
  408.                      (PUTHASH ,KEY-NUMBER ',FUNCTION-NAME *ESCAPE-DISPATCH-TABLE*)
  409.                      (DEFUN ,FUNCTION-NAME () . ,BODY)))
  410.           ('ALREADY-DEFINED-BY-SYSTEM-OR-USER
  411.            `(PUTHASH ,KEY-NUMBER ',FUNCTION-NAME *ESCAPE-DISPATCH-TABLE*))))
  412.  
  413.  
  414.  
  415. ;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  416.  
  417. ;;;       terminal escape definitions
  418.  
  419. ;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  420.  
  421.  
  422.  
  423.  
  424.  
  425.  
  426. (DEF-TERMINAL-ESCAPE #/[ T TERMINAL-EAT-TEMP      ; this may be wrong
  427.   ;; 'Enter Hold Screen Mode' ZEHS
  428.   (LET (I1 I2 FLAG)
  429.     (SETQ I1 (SERIAL-TYI))
  430.     (SETQ I2 (SERIAL-TYI))
  431.     (COND ((EQ I1 #\?) (SETQ FLAG T) (SERIAL-TYI))
  432.             ((OR (> I2 #\9) (< I2 #\0))
  433.              (SETQ I1 (- I1 #\0)))
  434.             (T (SETQ I1 (+ (* 10. (- I1 #\0)) (- I2 #\0)))
  435.                (SETQ I2 (SERIAL-TYI))))
  436.     (COND ((NOT FLAG)
  437.              (SELECTQ I2
  438.                (#\L (TERMINAL-INSERT-LINE I1))
  439.                (#\M (TERMINAL-DELETE-LINE I1)))))))
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446. (DEF-TERMINAL-ESCAPE #\\ T EXIT-EAT-TEMP
  447.   (TERMINAL-CLEAR-SCREEN))                        ; this may be wrong
  448.  
  449.  
  450.  
  451.  
  452.  
  453.  
  454. (DEF-TERMINAL-ESCAPE #\H T TERMINAL-HOME-CURSOR
  455.   (SEND *TERMINAL* ':HOME-CURSOR))
  456.  
  457.  
  458.  
  459.  
  460.  
  461. (DEF-TERMINAL-ESCAPE #\p T TERMINAL-REVERSE-VIDEO
  462.   (SETQ *REVERSE-VIDEO-FLAG* T)
  463.   NIL)
  464.  
  465.  
  466.  
  467.  
  468.  
  469. (DEF-TERMINAL-ESCAPE #\q T TERMINAL-NORMAL-VIDEO
  470.   (SETQ *REVERSE-VIDEO-FLAG* NIL)
  471.   NIL)
  472.  
  473.  
  474.  
  475.  
  476.  
  477.  
  478. (DEF-TERMINAL-ESCAPE #\x T TERMINAL-SET-MODE
  479.   (SELECTQ (SERIAL-TYI)
  480.     (#O10 (SETQ *AUTO-LF-ON-CR-FLAG* T))
  481.     (#O11 (SETQ *AUTO-CR-ON-LF-FLAG* T))
  482.     (:OTHERWISE ()))
  483.   (COND (*TERMINAL-DEBUG-MODE* (FORMAT INTERACTION-PANE "~% SET MODE:  ~O [~C] ")))
  484.   NIL)
  485.  
  486.  
  487.  
  488.  
  489.  
  490.  
  491. (DEF-TERMINAL-ESCAPE #\y T TERMINAL-RESET-MODE
  492.   (SELECTQ (SERIAL-TYI)
  493.     (#O10 (SETQ *AUTO-LF-ON-CR-FLAG* NIL))
  494.     (#O11 (SETQ *AUTO-CR-ON-LF-FLAG* NIL))
  495.     (:OTHERWISE ()))
  496.   (COND (*TERMINAL-DEBUG-MODE* (FORMAT INTERACTION-PANE "~% SET MODE:  ~O [~C] ")))
  497.   NIL)
  498.  
  499.  
  500.  
  501.  
  502.  
  503.  
  504.  
  505.  
  506.  
  507. (DEF-TERMINAL-ESCAPE #\C T TERMINAL-CURSOR-FORWARD
  508.   (MULTIPLE-VALUE-BIND (X Y)
  509.       (TERMINAL-READ-CURSORPOS)
  510.     (UNLESS (EQ X 79.)
  511.       (TERMINAL-SET-CURSORPOS (1+ X) Y))))
  512.  
  513.  
  514.  
  515.  
  516.  
  517. (DEF-TERMINAL-ESCAPE #\D T TERMINAL-CURSOR-BACKWARDS
  518.   (MULTIPLE-VALUE-BIND (X Y)
  519.       (TERMINAL-READ-CURSORPOS)
  520.     (UNLESS (EQ X 0)
  521.       (TERMINAL-SET-CURSORPOS (1- X) Y))))
  522.  
  523.  
  524.  
  525.  
  526.  
  527.  
  528. (DEF-TERMINAL-ESCAPE #\B T TERMINAL-CURSOR-DOWN
  529.   (MULTIPLE-VALUE-BIND (X Y)
  530.       (TERMINAL-READ-CURSORPOS)
  531.     (UNLESS (EQ Y (- (TERMINAL-CHARACTER-HEIGHT) 2))
  532.       (TERMINAL-SET-CURSORPOS X (1+ Y)))))
  533.  
  534.  
  535.  
  536.  
  537.  
  538. (DEF-TERMINAL-ESCAPE #\A T TERMINAL-CURSOR-UP
  539.   (MULTIPLE-VALUE-BIND (X Y)
  540.       (TERMINAL-READ-CURSORPOS)
  541.     (UNLESS (EQ Y 0)
  542.       (TERMINAL-SET-CURSORPOS X (1- Y)))))
  543.  
  544.  
  545.  
  546.  
  547. (DEF-TERMINAL-ESCAPE #\I T TERMINAL-REVERSE-INDEX
  548.   (MULTIPLE-VALUE-BIND (X Y)
  549.       (TERMINAL-READ-CURSORPOS)
  550.     (COND ((ZEROP X)
  551.              (TERMINAL-SET-CURSORPOS 0 (- (TERMINAL-CHARACTER-HEIGHT) 2))
  552.              (TERMINAL-DELETE-LINE)
  553.              (TERMINAL-SET-CURSORPOS X Y)
  554.              (TERMINAL-INSERT-LINE))
  555.             (T (TERMINAL-CURSOR-UP)))))
  556.  
  557.  
  558.  
  559.  
  560.  
  561.  
  562. (DEF-TERMINAL-ESCAPE #\n T TERMINAL-REPORT-CURSOR
  563.   (MULTIPLE-VALUE-BIND (X Y)
  564.       (TERMINAL-READ-CURSORPOS)
  565.     (SEND *SERIAL-STREAM* ':TYO #O33)             ;33 is ascii <altmode>
  566.     (SEND *SERIAL-STREAM* ':TYO #\Y)
  567.     (SEND *SERIAL-STREAM* ':TYO (+ 32. Y))
  568.     (SEND *SERIAL-STREAM* ':TYO (+ 32. X))))
  569.  
  570.  
  571.  
  572.  
  573.  
  574.  
  575. (DEF-TERMINAL-ESCAPE #\J T TERMINAL-CLEAR-EOF
  576.   (SEND *TERMINAL* #+3600 :clear-rest-of-window #-3600 ':CLEAR-EOF)    ;1;
  577.   )
  578.  
  579.  
  580.  
  581.  
  582.  
  583.  
  584. (DEF-TERMINAL-ESCAPE #\j T TERMINAL-SAVE-POS
  585.   (SETQ *CURSOR-SAVE*
  586.           (MULTIPLE-VALUE-LIST (TERMINAL-READ-CURSORPOS))))
  587.  
  588.  
  589.  
  590.  
  591.  
  592.  
  593. (DEF-TERMINAL-ESCAPE #\k T TERMINAL-RESTORE-POS
  594.   (TERMINAL-SET-CURSORPOS (CAR *CURSOR-SAVE*) (CADR *CURSOR-SAVE*)))
  595.  
  596.  
  597.  
  598.  
  599.  
  600. (DEF-TERMINAL-ESCAPE #\Y T TERMINAL-SET-POS
  601.   (LET ((Y (SERIAL-TYI))
  602.           (X (SERIAL-TYI)))
  603.     (cond (*terminal-debug-mode*
  604.              (format t "~&  setpos X=~D Y=~D" (- x 32.) (- y 32.))))
  605.     (TERMINAL-SET-CURSORPOS (- X 32.) (- Y 32.))))
  606.  
  607.  
  608.  
  609.  
  610.  
  611.  
  612. (DEF-TERMINAL-ESCAPE #\E T TERMINAL-CLEAR-SCREEN
  613.   (SEND *TERMINAL* #+3600 :clear-window #-3600 ':CLEAR-SCREEN))    ;1;
  614.  
  615.  
  616.  
  617.  
  618.  
  619. (DEF-TERMINAL-ESCAPE #\b T TERMINAL-CLEAR-BOD
  620.   (MULTIPLE-VALUE-BIND (X Y)
  621.       (TERMINAL-READ-CURSORPOS)
  622.     (DOTIMES (LINE (1- Y))
  623.       (TERMINAL-SET-CURSORPOS 0 LINE)
  624.       (TERMINAL-CLEAR-EOL))
  625.     (TERMINAL-SET-CURSORPOS 0 Y)
  626.     (DOTIMES (DUMMY X)
  627.       (TERMINAL-CLEAR-CHAR)
  628.       (TERMINAL-CURSOR-FORWARD))
  629.     (TERMINAL-CURSOR-BACKWARDS)))
  630.  
  631.  
  632.  
  633.  
  634.  
  635.  
  636.  
  637.  
  638. (DEF-TERMINAL-ESCAPE #\l T TERMINAL-CLEAR-LINE
  639.   (MULTIPLE-VALUE-BIND (X Y)
  640.       (TERMINAL-READ-CURSORPOS)
  641.     (TERMINAL-SET-CURSORPOS 0 Y)
  642.     (TERMINAL-CLEAR-EOL)
  643.     (TERMINAL-SET-CURSORPOS X Y)))
  644.  
  645.  
  646.  
  647.  
  648.  
  649.  
  650.  
  651.  
  652. (DEF-TERMINAL-ESCAPE #\o T TERMINAL-ERASE-BOL
  653.   (MULTIPLE-VALUE-BIND (X Y)
  654.       (TERMINAL-READ-CURSORPOS)
  655.     (TERMINAL-SET-CURSORPOS 0 Y)
  656.     (DOTIMES (DUMMY X)
  657.       (TERMINAL-CLEAR-CHAR)
  658.       (TERMINAL-CURSOR-FORWARD))
  659.     (TERMINAL-CURSOR-BACKWARDS)))
  660.  
  661.  
  662.  
  663.  
  664.  
  665.  
  666. (DEF-TERMINAL-ESCAPE #\K T TERMINAL-CLEAR-EOL
  667.   (SEND *TERMINAL* #+3600 :clear-rest-of-line #-3600 ':CLEAR-EOL))    ;1;
  668.  
  669.  
  670.  
  671.  
  672.  
  673.  
  674.  
  675. (DEF-TERMINAL-ESCAPE #\L T TERMINAL-INSERT-ONE-LINE
  676.   (TERMINAL-SAVE-POS-1)
  677.   (TERMINAL-SET-CURSORPOS 0 (- (TERMINAL-CHARACTER-HEIGHT) 2))
  678.   (TERMINAL-DELETE-LINE)
  679.   (TERMINAL-RESTORE-POS-1)
  680.   (TERMINAL-INSERT-LINE)
  681.   (TERMINAL-GOTO-BEG-OF-LINE))
  682.  
  683.  
  684.  
  685.  
  686.  
  687.  
  688.  
  689.  
  690. (DEF-TERMINAL-ESCAPE #\M T TERMINAL-DELETE-ONE-LINE
  691.   (TERMINAL-DELETE-LINE)
  692.   (TERMINAL-SAVE-POS-1)
  693.   (TERMINAL-SET-CURSORPOS 0 (- (TERMINAL-CHARACTER-HEIGHT) 2))
  694.   (TERMINAL-INSERT-LINE)
  695.   (TERMINAL-RESTORE-POS-1)
  696.   (TERMINAL-GOTO-BEG-OF-LINE))
  697.  
  698.  
  699.  
  700.  
  701.  
  702.  
  703. (DEF-TERMINAL-ESCAPE #\N T TERMINAL-DELETE-CHAR
  704.   (SEND *TERMINAL* ':DELETE-CHAR))
  705.  
  706.  
  707.  
  708.  
  709.  
  710.  
  711.  
  712. (DEF-TERMINAL-ESCAPE #\@ T TERMINAL-INSERT-MODE
  713.   (SETQ *INSERT-FLAG* T)
  714.   NIL)
  715.  
  716.  
  717.  
  718.  
  719.  
  720.  
  721.  
  722.  
  723. (DEF-TERMINAL-ESCAPE #\O T TERMINAL-EXIT-INSERT-MODE
  724.   (SETQ *INSERT-FLAG* NIL))
  725.  
  726.  
  727.  
  728.  
  729. (DEFSUBST ESCAPE-DISPATCH ()
  730.   (LET* ((KEYSTROKE (SERIAL-TYI))
  731.            (METHOD (GETHASH KEYSTROKE *ESCAPE-DISPATCH-TABLE*)))
  732.     (COND (METHOD
  733.              (FUNCALL METHOD)
  734.              (COND (*TERMINAL-DEBUG-MODE*
  735.                       (FORMAT INTERACTION-PANE "~%  ~O  [~:@C]  ~S " KEYSTROKE KEYSTROKE METHOD))))
  736.             (T (PUSH KEYSTROKE *BAD-ESCAPES*)
  737.                (COND (*TERMINAL-DEBUG-MODE*
  738.                         (FORMAT INTERACTION-PANE "~% ~O [~C] <<*** BAD ESCAPE CHARACTER"
  739.                                   KEYSTROKE KEYSTROKE)))))))
  740.  
  741.  
  742.  
  743.  
  744.  
  745.  
  746. (DEFUN READ-CHAR-FROM-SERIAL-STREAM-TO-TERMINAL ()
  747.   (LET ((KEYSTROKE (SERIAL-TYI)))
  748.  
  749.     (COND ((EQ KEYSTROKE #O33)                              ;ASCII <ALTMODE> [ESCAPE]
  750.              (ESCAPE-DISPATCH))
  751.  
  752.             ((< #O31 KEYSTROKE #O200)
  753.              (AND *LOGFILE* TURN-ON-LOGGING? (SEND *LOGFILE* ':TYO KEYSTROKE))  ;LOGFILE KLUDGE
  754.              (COND (*INSERT-FLAG* (TERMINAL-INSERT-CHAR)))
  755.              (LET ((STORE (TERMINAL-ERASE-ALUF)))
  756.                (TERMINAL-SET-ERASE-ALUF (IF *REVERSE-VIDEO-FLAG* TV:ALU-IOR TV:ALU-ANDCA))
  757.                (TERMINAL-CLEAR-CHAR)
  758.                (TERMINAL-SET-ERASE-ALUF STORE))
  759.              (COND ((> (TERMINAL-READ-CURSORPOS) (TERMINAL-CHARACTER-WIDTH))
  760.                       (TERMINAL-CR)))
  761.  
  762.              (TERMINAL-TYO KEYSTROKE))
  763.  
  764.             (T (SELECTQ KEYSTROKE
  765.                  (#O7 (TERMINAL-BEEP))
  766.                  (#O10 (TERMINAL-BACKSPACE))
  767.                  (#O11 (TERMINAL-TAB)
  768.                          (AND *LOGFILE* TURN-ON-LOGGING? (SEND *LOGFILE* ':TYO #O211)))
  769.                  (#O12 (TERMINAL-LINEFEED))
  770.                  (#O15 (TERMINAL-CR)
  771.                          (AND *LOGFILE* TURN-ON-LOGGING? (SEND *LOGFILE* ':TYO #O215)))
  772.                  (T (COND (*TERMINAL-DEBUG-MODE*
  773.                                (FORMAT INTERACTION-PANE
  774.                                          "~%Unrecognized /"control character/": ~O [~:@C]"
  775.                                          KEYSTROKE KEYSTROKE))))
  776.                  )))))
  777.  
  778.  
  779.  
  780.  
  781.  
  782.  
  783.  
  784.  
  785.  
  786.  
  787.  
  788.  
  789.  
  790.  
  791. (defun process-wait-listen (&rest streams)
  792.   "waits on input on the streams, returns the stream which has input ready."
  793.   (let ((stream1 (car streams)))
  794.     (cond
  795.       ((send stream1 ':listen) stream1)
  796.       (t
  797.        (with-stack-list (return-value nil)
  798.            (process-wait "wait-listen"
  799.                            #'(lambda (return-value streams)
  800.                                  (dolist (stream streams)
  801.                                    (if (send stream ':listen)
  802.                                          (return (setf (car return-value) stream)))))
  803.                            return-value
  804.                            streams)
  805.            (car return-value))))))
  806.  
  807.  
  808.  
  809.  
  810.  
  811.  
  812.  
  813.  
  814. ;;; sending characters from terminal to serial-stream:
  815.  
  816.  
  817.  
  818.  
  819. (DEFSUBST TERMINAL-TYI ()
  820.   (SEND *TERMINAL* ':TYI))
  821.  
  822.  
  823.  
  824. (defsubst serial-tyo (char)
  825.   (send *serial-stream* ':tyo char))
  826.  
  827.  
  828.  
  829.  
  830. ;;; this is now somewhat specialize for
  831. ;;; kermit by having this mouse menu tracking
  832. ;;; business, but its just the easiest way to
  833. ;;; keep the menu active while Connect is running.
  834. ;;; See the file "sys:kermit;kermit-window" for
  835. ;;; the extra meaning to this.
  836.  
  837.  
  838.  
  839. (defsubst terminal-any-tyi ()
  840.   (send *terminal* ':any-tyi))
  841.  
  842. (defun read-char-from-keyboard-to-serial-stream ()
  843.   (declare (special *escchr*))
  844.   (let ((key-stroke (terminal-any-tyi)))
  845.     (cond ((and (not (atom key-stroke)) (eq (car key-stroke) ':menu))
  846.              (funcall (cadddr key-stroke) ':execute (cadr key-stroke)))
  847.             ((not (fixnump key-stroke)) (beep))
  848.             (t (if *local-echo-mode*
  849.                      (format *terminal* "~C" key-stroke))
  850.                (when (memq (ldb %%kbd-char key-stroke) '(#\Rubout #+(not 3600) #\Delete))    ;1;
  851.                  (setq key-stroke (dpb 177 %%kbd-char key-stroke)))
  852.                (select key-stroke
  853.                  (*escchr* (network-keystroke-handler))
  854.                  (#\Call (serial-tyo #\ ))        ; send a [top-c] (for ascii ctrl-z)
  855.          #+3600
  856.          (#\Escape (serial-tyo #o33))    ;1; send escape character, too.
  857.                  (t (let
  858.  
  859.                         ((char (ldb %%kbd-char key-stroke))
  860.                          (control (ldb %%kbd-control key-stroke))
  861.                          (meta (ldb %%kbd-meta key-stroke)))
  862.  
  863.                         (cond ((and (eq meta 1) (eq control 1))
  864.                                  (serial-tyo
  865.                    #+3600 #\c-Z    ;1; Will this do it??
  866.                    #-3600 #\top-c)                 ;;   [TOP-C] IS An Ascii CTRL-Z
  867.                                  (serial-tyo char))
  868.                                 (t (cond ((eq control 1) (setq char (logand char 37))))
  869.                                    (cond ((not (zerop meta))
  870.                                             (cond (*use-bit-7-for-meta*
  871.                                                      (setq char (logior #o200 (logand char #o177))))
  872.                                                     (t (serial-tyo #o33)
  873.                                                        (setq char (logior char #o40))))))
  874.                                    (serial-tyo char)))
  875.                         nil)))))))
  876.  
  877.  
  878.  
  879.  
  880.  
  881.  
  882.  
  883. (defun network-keystroke-handler ()
  884.   (declare (special kermit-frame *escchr*))
  885.   (terminal-network-prompt)                       ;PROMPT THE USER
  886.  
  887.   (let ((terminal-io interaction-pane))
  888.  
  889.     ;1; I think that tv:with-selection-substitute on LMI would substitute kermit-frame for
  890.     ;1; interaction-pane if interaction-pane is unbound, so that is what I will explicitly do for 3600.
  891.     (#-3600 tv:with-selection-substitute #-3600 (interaction-pane kermit-frame)
  892.      #+3600 let #+3600 ((interaction-pane (if (boundp 'interaction-pane) interaction-pane kermit-frame)))
  893.  
  894.       (let ((key-stroke (char-upcase (terminal-tyi))))
  895.  
  896.           (unless (eq key-stroke #\rubout)
  897.             (format interaction-pane "~:@C" key-stroke))
  898.  
  899.           (condition-case ()
  900.  
  901.               (prog1                                        ; hey, return ':close sometimes
  902.                (selectq key-stroke
  903.  
  904.                  (#\CLEAR-SCREEN (terminal-clear-screen))
  905.                  (#\CONTROL-CLEAR-SCREEN (send interaction-pane
  906.                            #+3600 :clear-window    ;1; clear-screen is
  907.                            #-3600 ':clear-screen))    ;1; obsolete on 3600
  908.                  ((#\HELP #/H) (terminal-network-help))
  909.                  (#\SPACE nil)
  910.                  (#\control-y (terminal-control-y-pop-up-ed-string-hack))
  911.                  (#/E (terminal-read-eval-print))
  912.                  (#\control-d
  913.                     (format t "~&Turning ~A Terminal Debug mode.~%"
  914.                               (if (setq *terminal-debug-mode* (not *terminal-debug-mode*))
  915.                                   "ON" "OFF")))
  916.                  (#/D (format t "~&Turning ~A Local Echo mode.~%"
  917.                               (if (setq *local-echo-mode* (not *local-echo-mode*))
  918.                                   "ON" "OFF")))
  919.                  (#\CONTROL-B (terminal-get-and-set-new-baud-rate))
  920.                  (#\CONTROL-S (terminal-set-status-of-connection))
  921.                  (#\STATUS (terminal-show-status-of-connection))
  922.                  (#/F (terminal-flush-input-buffer))
  923.                  (#/L (terminal-start-logging))
  924.                  (#\C-L (terminal-close-logging))
  925.                  (#/K (format interaction-pane "...closing stream ~S..."
  926.                                   *serial-stream*)
  927.                         (send *serial-stream* ':close ':abort)
  928.                         (format interaction-pane "and disconnecting.~%")
  929.                         ':close)
  930.  
  931.                  ;;KERMIT PROTOCOL:
  932.  
  933.                  (#/0 (terminal-transmit-nul))
  934.                  (#/B (terminal-transmit-break))
  935.                  (#/C (format interaction-pane "...disconnecting.~%")
  936.                         ':close)
  937.                  (#/P (terminal-push-to-system-command-processor))
  938.                  (#/Q (terminal-quit-logging))
  939.                  (#/R (terminal-resume-logging))
  940.                  (#/S (terminal-show-status-of-connection))
  941.                  (#/? (terminal-network-help))
  942.                  (#\NETWORK (terminal-transmit-network-escape-character))
  943.                  (#\RUBOUT)                       ;do nothing
  944.                  (:otherwise (if (eq key-stroke kermit:*escchr*)
  945.                                      (terminal-transmit-network-escape-character)
  946.                                    (if (not (eq key-stroke #\RUBOUT))
  947.                                          (format interaction-pane
  948.                                                    "  <-- ?? Unknown argument to <NETWORK> ??")))))
  949.                (terpri interaction-pane))
  950.             (sys:abort nil))))))
  951.  
  952.  
  953. (defun terminal-control-y-pop-up-ed-string-hack ()
  954.   (let
  955.     ((string-to-transmit?                         ;null if aborted
  956.        (zwei:pop-up-edstring ""
  957.                                    '(:mouse)
  958.                                    ()
  959.                                    (- (tv:sheet-inside-right *terminal*)
  960.                                         (tv:sheet-inside-left *terminal*))
  961.                                    (- (tv:sheet-inside-bottom *terminal*)
  962.                                         (tv:sheet-inside-top *terminal*))
  963.                                    "Edit Text and hit <END> to transmit.")))
  964.     (if string-to-transmit?
  965.           (loop for i from 0 below (array-active-length string-to-transmit?)
  966.                 as char = (aref string-to-transmit? i)
  967.                 doing (send *serial-stream* ':tyo char)))))
  968.  
  969. (DEFUN TERMINAL-NETWORK-HELP ()
  970.   ;1; with-help-stream not on 3600...
  971.   (#-3600 SI:WITH-HELP-STREAM #-3600 (S :LABEL '(:STRING "Terminal Network Help"
  972.                                                      :FONT FONTS:METSI :TOP :CENTERED)
  973.                                 :SUPERIOR *TERMINAL*)
  974.    #+3600 with-kermit-typeout-stream   #+3600 S  #+3600 '(:STRING "Terminal Network Help"
  975.                               :FONT FONTS:METSI :TOP)
  976.    #-3600
  977.     (FORMAT S "  
  978. Single-keystroke Arguments to the <NETWORK> escape:
  979.  
  980.  C                Close -- escape back to kermit command level
  981.  <ctrl> Y       Yank some text into a pop up window and send it thru serial stream
  982.  <ctrl> D       Debug toggle -- toggles terminal debug mode
  983.  D              Duplex toggle -- switch between local and remote terminal echoing
  984.  K              Kill stream -- send current stream a :close message and disconnect
  985.  <clear-screen>     Clear terminal screen
  986.  <ctrl><clear>  Clear interaction screen
  987.  F              Flush serial input buffer
  988.  <ctrl>B        Control Baud -- set baud rate
  989.  E                Eval -- evaluate lisp expression
  990.  P              Push -- break to lisp. Hit <resume> to return
  991.  B                Transmit a break
  992.  0                Transmit a nul
  993.  s,<status>     Show serial stream status
  994.  L              Log connection in a disk file
  995.  <control>L     Close logging to disk file
  996.  Q              Quit logging temporarily
  997.  R              Resume logging
  998.  ?,<help>,h     type this stuff  ~%")
  999.  
  1000.     #+3600
  1001.     (FORMAT S "  
  1002. Single-keystroke Arguments to the <NETWORK> escape:
  1003.  
  1004.  C               Close -- escape back to kermit command level
  1005.  <ctrl> Y        Yank some text into a pop up window and send it thru serial stream
  1006.  <ctrl> D        Debug toggle -- toggles terminal debug mode
  1007.  D               Duplex toggle -- switch between local and remote terminal echoing
  1008.  K               Kill stream -- send current stream a :close message and disconnect
  1009.  <refresh>       Clear terminal screen
  1010.  <ctrl><refresh> Clear interaction screen
  1011.  F               Flush serial input buffer
  1012.  <ctrl>B         Control Baud -- set baud rate
  1013.  E               Eval -- evaluate lisp expression
  1014.  P               Push -- break to lisp. Hit <resume> to return
  1015.  B               Transmit a break
  1016.  0               Transmit a nul
  1017.  S               Show serial stream status
  1018.  L               Log connection in a disk file
  1019.  <control>L      Close logging to disk file
  1020.  Q               Quit logging temporarily
  1021.  R               Resume logging
  1022.  ?,<help>,h      Help, type this stuff  ~%")
  1023.     ))
  1024.  
  1025.  
  1026.  
  1027. (defun toggle-duplex ()
  1028.   (format t "~&Local Echo mode being turned ~A.~%"
  1029.             (if *local-echo-mode* "OFF" "ON"))
  1030.   (setq *local-echo-mode* (not *local-echo-mode*)))
  1031.  
  1032. (defun terminal-flush-input-buffer ()
  1033.   (send *serial-stream* ':clear-input))
  1034.  
  1035. ;;; this macro here because this gets compiled first (before kermit-window).
  1036.  
  1037. (defmacro with-second-font-and-more-processing (window &body body)
  1038.   "sets window's font to its second font and turns on more processing during body.
  1039. sets them back to the way they were afterwards."
  1040.   (let ((font (gensym))
  1041.           (more-p (gensym)))
  1042.  
  1043.        `(let ((,font (send ,window ':current-font))
  1044.                (,more-p (send ,window ':more-p)))
  1045.             (unwind-protect
  1046.                 (progn
  1047.                     (send ,window ':set-current-font 1)
  1048.                     (send ,window ':set-more-p t)
  1049.                     ,@body)
  1050.               (send ,window ':set-current-font ,font)
  1051.               (send ,window ':set-more-p ,more-p)))))
  1052.  
  1053. (DEFUN TERMINAL-TRANSMIT-NETWORK-ESCAPE-CHARACTER ()
  1054.   (declare (special *escchr*))
  1055.   (serial-tyo *escchr*))
  1056.  
  1057.  
  1058.  
  1059. (defun terminal-show-status-of-connection ()
  1060.   ;1; Once again, I changed this since 3600 doesn't have with-help-stream.
  1061.   (#-3600 si:with-help-stream #-3600 (standard-output
  1062.                                :label `(:string "Terminal Status"
  1063.                                                     ,@(if (boundp 'fonts:metsi)
  1064.                                                             '(:font fonts:metsi))
  1065.                                                     :top :centered)
  1066.                                :superior *terminal*)
  1067.    #+3600 with-kermit-typeout-stream #+3600 standard-output
  1068.    #+3600 `(:string "Terminal Status"
  1069.         ,@(if (boundp 'fonts:metsi) '(:font fonts:metsi)) :top)
  1070.     ;; status of logging:
  1071.     (format t "~&Logging is ~A~A."
  1072.               (if *logfile* "ON" "OFF")
  1073.               (if *logfile*
  1074.                     (if turn-on-logging? " and ENABLED" " but DISABLED")
  1075.                 ""))
  1076.     ;; and show logfile name if any:
  1077.     (if *logfile*
  1078.           (format t "~&Logfile name is: ~A" *logfile*))
  1079.     ;; status of echo:
  1080.     (format t "~&Local-echo-mode is ~A."
  1081.               (if *local-echo-mode* "ON" "OFF"))
  1082.     ;; terminal sizes:
  1083.     (let ((font (send *terminal* ':current-font)))
  1084.       (format t "~&Terminal sizes:~% Height: ~D lines; ~D pixels per line.~A"
  1085.                 (terminal-character-height)
  1086.                 (tv:font-char-height font)
  1087.                 (format nil "~% Width: ~D characters; ~D pixels per character."
  1088.                           (terminal-character-width)
  1089.                           (tv:font-char-width font))))
  1090.  
  1091.     ;; line status:
  1092.     (cond
  1093.      #-3600 ((typep *serial-stream* 'unix:unix-stream)    ;1; no unix package on 3600
  1094.              (describe *serial-stream*))
  1095.      #-3600 ((typep *serial-stream* 'si:sdu-serial-stream)    ;1; no sdu stuff on 3600
  1096.              (format t "~%baud rate of ~A: ~d"
  1097.                        *serial-stream*
  1098.                        (send *serial-stream* ':baud-rate))
  1099.              (si:sdu-serial-status))
  1100.             ((typep *serial-stream* 'si:serial-stream)
  1101.              (format t "~%baud rate of ~A: ~d"
  1102.                        *serial-stream*
  1103.                        (send *serial-stream* ':get ':baud))
  1104.              #-3600 (si:serial-status)        ;1; no serial-status on 3600, so guess at what it describes...
  1105.          #+3600 (progn
  1106.               (format t "~%parity is ~d ~
  1107.                                  ~%number of data bits is ~d ~
  1108.                                  ~%number of stop bits is ~d ~
  1109.                                  ~%xon-xoff protocol is ~d"
  1110.                   (send *serial-stream* ':get ':parity)
  1111.                   (send *serial-stream* ':get ':number-of-data-bits)
  1112.                   (send *serial-stream* ':get ':number-of-stop-bits)
  1113.                   (send *serial-stream* ':get ':xon-xoff-protocol)))
  1114.          )
  1115.             (t (describe *serial-stream*)))
  1116.  
  1117.     ))
  1118.  
  1119.  
  1120.  
  1121.  
  1122. ;;; LOGGING: here it is.
  1123.  
  1124. ;;; All we do is this: if the incoming character from the
  1125. ;;; serial stream is a printing ascii character, we put it
  1126. ;;; in the log file. Printing characters are in the range
  1127. ;;; 32 to 177 plus 11, 14, and 15 (octal). Linefeeds and any
  1128. ;;; other control characters are not sent. No input from  the
  1129. ;;; user's side is included whatsoever. The code for the actual
  1130. ;;; capture of characters is thus isolated within the function
  1131. ;;; read-char-from-serial-stream-to-terminal.
  1132.  
  1133.  
  1134.  
  1135.  
  1136.  
  1137. (defun terminal-start-logging ()
  1138.   (cond (*logfile*
  1139.            (format interaction-pane "~& Cannot open a new logfile!!")
  1140.            (tv:beep))
  1141.           ((setq *logfile*
  1142.                  (open (terminal-get-logfile-name-from-user) '(:out)))
  1143.            (setq turn-on-logging? t)
  1144.            (format interaction-pane "~& Logging output to file ~A~%"
  1145.                      (send *logfile* ':truename)))
  1146.           (t (format interaction-pane "~& Unable to open logfile.")
  1147.              (tv:beep)))
  1148.   nil)
  1149.  
  1150.  
  1151.  
  1152.  
  1153.  
  1154.  
  1155.  
  1156.  
  1157.  
  1158.  
  1159.  
  1160.  
  1161. (defun terminal-get-logfile-name-from-user ()
  1162.   (let ((default-pathname
  1163.             (fs:merge-pathname-defaults
  1164.               "TERMINAL.LOG"
  1165.               (if (and (boundp 'kermit-default-pathname)    ;1; added :unbound check
  1166.                (neq kermit-default-pathname :unbound))
  1167.                     kermit-default-pathname
  1168.                 (fs:user-homedir)))))
  1169.     (fs:merge-pathname-defaults
  1170.       (prompt-and-read
  1171.           ':string-trim
  1172.           (format nil
  1173.                     "~&Name log file: (DEFAULT: ~A) "    ;1; just removed ">" from end...
  1174.                     default-pathname))
  1175.       default-pathname)))
  1176.  
  1177.  
  1178.  
  1179.  
  1180.  
  1181.  
  1182.  
  1183.  
  1184.  
  1185.  
  1186.  
  1187. (defun terminal-quit-logging ()
  1188.   (cond ((and *logfile* turn-on-logging?)
  1189.            (format interaction-pane
  1190.                      "~&Turning off logged output to ~A~%"
  1191.                      (send *logfile* ':truename))
  1192.            (setq turn-on-logging? nil))
  1193.           ((not *logfile*)
  1194.            (format interaction-pane
  1195.                      "~& ?? There is no logging being done.~%"))
  1196.           ((not turn-on-logging?)
  1197.            (format interaction-pane
  1198.                      "~& ?? Logging is not turned on.~%"))))
  1199.  
  1200.  
  1201.  
  1202.  
  1203.  
  1204.  
  1205.  
  1206.  
  1207.  
  1208.  
  1209.  
  1210.  
  1211. (DEFUN TERMINAL-RESUME-LOGGING ()
  1212.   (COND ((AND *LOGFILE* (NOT TURN-ON-LOGGING?))
  1213.            (FORMAT INTERACTION-PANE "~&Turning on logged output to ~A~%"
  1214.                      (SEND *LOGFILE* ':TRUENAME))
  1215.            (SETQ TURN-ON-LOGGING? T))
  1216.           ((NOT *LOGFILE*)
  1217.            (FORMAT INTERACTION-PANE
  1218.                      "~& ?? There is no logging being done.~%"))
  1219.           (TURN-ON-LOGGING?
  1220.            (FORMAT INTERACTION-PANE
  1221.                      "~& ?? Logging is not turned off.~%"))))
  1222.  
  1223.  
  1224.  
  1225.  
  1226.  
  1227.  
  1228.  
  1229.  
  1230.  
  1231. (DEFUN TERMINAL-CLOSE-LOGGING ()
  1232.   (COND (*LOGFILE*
  1233.            (FORMAT INTERACTION-PANE "~&Closing logged output to ~A" (SEND *LOGFILE* ':TRUENAME))
  1234.            (SEND *LOGFILE* ':CLOSE)
  1235.            (SETQ *LOGFILE* NIL)
  1236.            (SETQ TURN-ON-LOGGING? NIL))
  1237.           (T (FORMAT INTERACTION-PANE
  1238.                        " ?? There is no log file to close~%"))))
  1239.  
  1240.  
  1241. #-common
  1242. (DEFUN TERMINAL-PUSH-TO-SYSTEM-COMMAND-PROCESSOR ()
  1243.   (LET ((TERMINAL-IO INTERACTION-PANE))
  1244.       (BREAK KERMIT)))
  1245.  
  1246. #+common
  1247. (DEFUN TERMINAL-PUSH-TO-SYSTEM-COMMAND-PROCESSOR ()
  1248.   (LET ((TERMINAL-IO INTERACTION-PANE))
  1249.       (BREAK "Kermit Break while in Connect.")))
  1250.  
  1251.  
  1252.  
  1253.  
  1254.  
  1255.  
  1256.  
  1257. (DEFUN TERMINAL-TRANSMIT-NUL ()
  1258.   (SERIAL-TYO 0))
  1259.  
  1260. (DEFUN TERMINAL-CLOSE-CONNECTION ()
  1261.   NIL)
  1262.  
  1263.  
  1264.  
  1265.  
  1266.  
  1267.  
  1268.  
  1269.  
  1270. (DEFUN TERMINAL-GET-AND-SET-NEW-BAUD-RATE ()    ;1; had to change this since 3600 will not be object-code compatible,
  1271.   (LET (TO-WHAT)                ;1; and does not have stuff for selecting processor type.
  1272.     #-3600 (SELECTOR SI:PROCESSOR-TYPE-CODE EQ
  1273.          (SI:LAMBDA-TYPE-CODE
  1274.            (SEND *SERIAL-STREAM*
  1275.              ':SET-BAUD-RATE
  1276.              (IF (ZEROP (SETQ TO-WHAT
  1277.                       (PROMPT-AND-READ ':NUMBER
  1278.                                "~%The current baud rate is ~D. Answering with 0 keeps it.~%Baud rate? >>"
  1279.                                (SEND *SERIAL-STREAM* ':BAUD-RATE))))
  1280.              (SEND *SERIAL-STREAM* ':BAUD-RATE)
  1281.              TO-WHAT)))
  1282.          (SI:CADR-TYPE-CODE
  1283.            (SEND *SERIAL-STREAM*
  1284.              ':PUT
  1285.              ':BAUD
  1286.              (IF (ZEROP (SETQ TO-WHAT
  1287.                       (PROMPT-AND-READ ':NUMBER
  1288.                                "~%The current baud rate is ~D. Answering with 0 keeps it.~%Baud rate? >>"
  1289.                                (SEND *SERIAL-STREAM* ':GET ':BAUD))))
  1290.              (SEND *SERIAL-STREAM* ':GET ':BAUD)
  1291.              TO-WHAT))))
  1292.     #+3600 (SEND *SERIAL-STREAM*
  1293.          ':PUT
  1294.          ':BAUD
  1295.          (IF (ZEROP (SETQ TO-WHAT
  1296.                   (PROMPT-AND-READ ':NUMBER
  1297.                            "~%The current baud rate is ~D. Answering with 0 keeps it.~%Baud rate? >>"
  1298.                            (SEND *SERIAL-STREAM* ':GET ':BAUD))))
  1299.              (SEND *SERIAL-STREAM* ':GET ':BAUD)
  1300.              TO-WHAT))
  1301.     ))
  1302.  
  1303.  
  1304.  
  1305.  
  1306.  
  1307.  
  1308. (DEFUN TERMINAL-SET-STATUS-OF-CONNECTION ()
  1309.   NIL)
  1310.  
  1311.  
  1312.  
  1313.  
  1314.  
  1315.  
  1316.  
  1317.  
  1318.  
  1319.  
  1320. (DEFUN TERMINAL-READ-EVAL-PRINT ()
  1321.   (FORMAT INTERACTION-PANE "~%EVAL>")
  1322.   (LET ((DEBUG-IO INTERACTION-PANE)
  1323.           (QUERY-IO INTERACTION-PANE)
  1324.           (ERROR-OUTPUT INTERACTION-PANE)
  1325.           (TERMINAL-IO INTERACTION-PANE)
  1326.           (STANDARD-INPUT INTERACTION-PANE)
  1327.           (STANDARD-OUTPUT INTERACTION-PANE))
  1328.     (CONDITION-CASE ()
  1329.           (PRINT (EVAL (READ)))
  1330.       (SYS:ABORT NIL))))
  1331.  
  1332.  
  1333.  
  1334.  
  1335.  
  1336.  
  1337.  
  1338.  
  1339.  
  1340.  
  1341.  
  1342. #-3600
  1343. (DEFUN TERMINAL-TRANSMIT-BREAK ()
  1344.  
  1345.   ;;PUT ASCII NUL [0] ON LINE FOR 1/4 SECOND
  1346.   ;1; Weird, but for 3600, the first parameter to time-difference
  1347.   ;1; is assumed to be later than the second, so had to change this.
  1348.   ;1; But.... this still doesn't work.... what you need is next version.
  1349.   (LOOP WITH TIME = (TIME)
  1350.           DOING (COND ((> #-3600 (TIME-DIFFERENCE TIME (TIME))
  1351.               #+3600 (time-difference (time) time)
  1352.               15.)
  1353.                          (RETURN))
  1354.                         (T (SERIAL-TYO 0)))))
  1355.  
  1356. #+3600
  1357. (defun terminal-transmit-break ()
  1358.   (send *serial-stream* :send-break))        ;1; makes sense...
  1359.  
  1360. (DEFUN TERMINAL-NETWORK-PROMPT ()
  1361.   (FORMAT INTERACTION-PANE "~&NETWORK>"))
  1362.  
  1363.  
  1364.  
  1365.  
  1366.  
  1367. ;1; The defaults for these instance variable seem to have to be set here,
  1368. ;1; as well as in the defconst/defvar of the corresponding globals.
  1369. ;1; If not, they appear to take the global value when not connected,
  1370. ;1; and the following value during connection.
  1371.  
  1372. (defflavor kterm-state
  1373.              ;; analogous to kstate.
  1374.              ;; these are all used free by connect & its subroutines.
  1375.              ((*logfile* nil)
  1376.               (turn-on-logging? nil)
  1377.               (*local-echo-mode* nil)
  1378.               (*terminal-debug-mode* nil)
  1379.               (*insert-flag* nil)
  1380.               (*reverse-video-flag* nil)
  1381.               (*cursor-save* '(0 0))
  1382.               (*system-position* '(0 0))
  1383.               (*use-bit-7-for-meta* nil)
  1384.               (*auto-cr-on-lf-flag* nil)
  1385.           (*auto-lf-on-cr-flag* nil)    ;1; accidentally left out?
  1386.           )
  1387.              ()
  1388.   :special-instance-variables)
  1389.  
  1390.  
  1391. ;; for kermit window interface to call
  1392.  
  1393. (defmethod (kterm-state :make-connection)
  1394.          (serial-stream terminal-stream)
  1395.   ;; now all the special instance variables are bound.
  1396.   (connect serial-stream terminal-stream))
  1397.  
  1398.  
  1399. ;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  1400. ;;;       CONNECT
  1401. ;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  1402.  
  1403.  
  1404.  
  1405.  
  1406.  
  1407.  
  1408.  
  1409.  
  1410. (defun connect
  1411.  
  1412.        ;; bind various streams
  1413.  
  1414.        (*serial-stream* *terminal*
  1415.  
  1416.           &optional
  1417.           (error-output error-output)
  1418.           (debug-io debug-io)
  1419.  
  1420.           &aux
  1421.           (interaction-pane (if (boundp 'interaction-pane)
  1422.                                     interaction-pane *terminal*))   
  1423.           (*ttyfd* *serial-stream*))
  1424.  
  1425.   "Make *terminal* a virtual terminal connected with *serial-stream*, a serial stream.
  1426.  
  1427.           A simulation of a Heath//H19//Z29 terminal is attempted
  1428.           for communication with ASCII terminals. Do <NETWORK> <HELP>
  1429.           for help and feature explanation. <Network>C to Close (disconnect)"
  1430.   (declare (special *ttyfd*))
  1431.  
  1432.   (let ((char-aluf (send *terminal* ':char-aluf)))
  1433.  
  1434.     (loop initially
  1435.  
  1436.             (send *terminal* ':set-char-aluf tv:alu-xor)
  1437.  
  1438.             with winner = (process-wait-listen *serial-stream* *terminal*)
  1439.  
  1440.             doing
  1441.  
  1442.             (cond ((eq winner *serial-stream*)
  1443.                      (read-char-from-serial-stream-to-terminal)
  1444.                      (setq winner (process-wait-listen *terminal* *serial-stream*)))
  1445.  
  1446.                     (t (cond ((eq (read-char-from-keyboard-to-serial-stream) ':close)
  1447.                                 (loop-finish))    ; we're done
  1448.                                (t (setq winner (process-wait-listen *serial-stream* *terminal*))))))
  1449.  
  1450.             finally
  1451.             (send *terminal* ':set-char-aluf char-aluf)
  1452.             (return nil))))
  1453.